(FILECREATED "29-AUG-73 19:03:04" RECORD)


  (LISPXPRINT (QUOTE RECORDVARS)
              T)
  [RPAQQ RECORDVARS
         ((FNS RECORD TYPERECORD RECDO COMPOSE0 'CAR 'CDR 'CONS 
               COMPOSE1 COMPOSE2 COMPOSE3 COMPOSE4 MAKECROPFN 
               MAKECROPFN1 CLISPLOOKUP LOOK)
          (PROP CLISPWORD COMPOSE compose)
          (PROP MACRO COMPOSE compose)
          (P (ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORD "records")))
          (P (ADDTOVAR CLISPRETTYWORDS compose COMPOSE))
          (P (ADDTOVAR CLISPWORDS COMPOSE))
          (VARS (CHANGEDRECLST NIL]
(DEFINEQ

(RECORD
  [LAMBDA (NAME FIELD)
    (OR (AND FIELD (/PUT NAME (QUOTE RECORD)
                         FIELD))
        (SETQ FIELD (GETP NAME (QUOTE RECORD)))
        (ERROR "empty record" NAME))
    (RECDO FIELD NIL)
    (SETQ CHANGEDRECLST (CONS NAME CHANGEDRECLST))
    NAME])

(TYPERECORD
  [LAMBDA (NAME FIELD)
    (OR (AND FIELD (/PUT NAME (QUOTE TYPERECORD)
                         FIELD))
        (SETQ FIELD (GETP NAME (QUOTE TYPERECORD)))
        (ERROR "empty record" NAME))
    (RECDO FIELD (QUOTE (D)))
    [/PUTD (SETQ FIELD (PACK (LIST NAME "?")))
           (LIST (QUOTE LAMBDA)
                 (QUOTE (IDVAR))
                 (LIST (QUOTE EQ)
                       (QUOTE (CAR IDVAR))
                       (KWOTE NAME]
    [/PUT FIELD (QUOTE MACRO)
          (LIST (QUOTE (RECORDVAR))
                (LIST (QUOTE EQ)
                      (QUOTE (CAR RECORDVAR))
                      (LIST (QUOTE QUOTE)
                            NAME]
    (SETQ CHANGEDRECLST (CONS NAME CHANGEDRECLST))
    NAME])

(RECDO
  [LAMBDA (FORMAT RCROPS)
    (COND
      ((NULL FORMAT)
        NIL)
      ((LISTP FORMAT)
        (RECDO (CAR FORMAT)
               (CONS (QUOTE A)
                     RCROPS))
        (RECDO (CDR FORMAT)
               (CONS (QUOTE D)
                     RCROPS)))
      [(LITATOM FORMAT)
        (/PUTD FORMAT (MAKECROPFN RCROPS))
        (/PUT FORMAT (QUOTE MACRO)
              (LIST (QUOTE (RECORDFIELDVAR))
                    (MAKECROPFN1 RCROPS)))
        [/PUT FORMAT (QUOTE ACCESSFN)
              (CONS FORMAT (SETQ TEM (PACK (LIST "RPLAC." FORMAT]
        (/PUT TEM (QUOTE ACCESSFN)
              FORMAT)
        (/PUT TEM (QUOTE MACRO)
              (LIST (QUOTE X)
                    (LIST (QUOTE LOOK)
                          [KWOTE (PACK (LIST (QUOTE RPLAC)
                                             (CAR RCROPS]
                          [LIST (QUOTE DSUBST)
                                (QUOTE (CAR X))
                                (QUOTE (QUOTE RECORDFIELDVAR))
                                (KWOTE (MAKECROPFN1 (CDR RCROPS]
                          (QUOTE (CADR X]
      (T (ERROR "Invalid record field" FORMAT])

(COMPOSE0
  [LAMBDA (L FIELD !RECORDFLG)

          (* Constructs a composition of FIELD using things 
          from L -
          First L must be split up into things in field)


    (PROG (VAR DEF FROMVAR)
          [COND
            ((OR (EQ (CAR L)
                     (QUOTE FROM))
                 (EQ (CAR L)
                     (QUOTE from)))
              (SETQ FROMVAR (CADR L))
              (SETQ L (CDDR L]
          [SETQ DEF (COMPOSE1 L FIELD (AND FROMVAR
                                           (COND
                                             ((LISTP FROMVAR)
                                               (SETQQ VAR COMPOSEVAR))
                                             (!RECORDFLG ('CDR FROMVAR))
                                             (T FROMVAR]
          [COND
            (VAR (SETQ DEF (LIST (LIST (QUOTE LAMBDA)
                                       (LIST VAR)
                                       DEF)
                                 (COND
                                   (!RECORDFLG ('CDR FROMVAR))
                                   (T FROMVAR]
          (COND
            (!RECORDFLG ('CONS (KWOTE !RECORDFLG)
                               DEF))
            (T DEF])

('CAR
  [LAMBDA (X)
    (AND X (PROG [(TEM (FASSOC (CAR X)
                               (QUOTE ((CAR . CAAR)
                                       (CDR . CADR)
                                       (CAAR . CAAAR)
                                       (CADR . CAADR)
                                       (CDAR . CADAR)
                                       (CDDR . CADDR)
                                       (CAAAR . CAAAAR)
                                       (CAADR . CAAADR)
                                       (CADAR . CAADAR)
                                       (CADDR . CAADDR)
                                       (CDAAR . CADAAR)
                                       (CDADR . CADADR)
                                       (CDDAR . CADDAR)
                                       (CDDDR . CADDDR]
                 (COND
                   (TEM (LIST (CDR TEM)
                              (CADR X)))
                   (T (LIST (QUOTE CAR)
                            X])

('CDR
  [LAMBDA (X)
    (AND X (PROG [(TEM (FASSOC (CAR X)
                               (QUOTE ((CAR . CDAR)
                                       (CDR . CDDR)
                                       (CAAR . CDAAR)
                                       (CADR . CDADR)
                                       (CDAR . CDDAR)
                                       (CDDR . CDDDR)
                                       (CAAAR . CDAAAR)
                                       (CAADR . CDAADR)
                                       (CADAR . CDADAR)
                                       (CADDR . CDADDR)
                                       (CDAAR . CDDAAR)
                                       (CDADR . CDDADR)
                                       (CDDAR . CDDDAR)
                                       (CDDDR . CDDDDR]
                 (COND
                   (TEM (LIST (CDR TEM)
                              (CADR X)))
                   (T (LIST (QUOTE CDR)
                            X])

('CONS
  [LAMBDA (CARPART CDRPART)
    (COND
      [(OR (EQ (CAR CDRPART)
               (QUOTE LIST))
           (NOT (CAR CDRPART)))
        (CONS (QUOTE LIST)
              (CONS CARPART (CDR CDRPART]
      (T (LIST (QUOTE CONS)
               CARPART CDRPART])

(COMPOSE1
  [LAMBDA (L FIELD DEF)
    (PROG (K)
          (COND
            ((SETQ K (COMPOSE2 L FIELD DEF))
              (CAR K))
            (FROMVAR DEF)
            (T (COMPOSE4 FIELD])

(COMPOSE2
  [LAMBDA (L FIELD DEF)

          (* Constructs the composition of FIELD from L , 
          returning NIL if none of the fields in FIELD are 
          mentioned in L -
          and <consexpression> otherwise)


    (COND
      ((NULL FIELD)
        NIL)
      [(ATOM FIELD)
        (AND (MEMB FIELD L)
             (LIST (SUBST (LIST FIELD FROMVAR)
                          (QUOTE **)
                          (GET L FIELD]
      (T (PROG [(KD (COMPOSE2 L (CDR FIELD)
                              ('CDR DEF)))
                (KA (COMPOSE2 L (CAR FIELD)
                              ('CAR DEF]
               (AND (NULL KA)
                    (NULL KD)
                    (RETURN NIL))
               (RETURN (LIST ('CONS [COND
                                      (KA (CAR KA))
                                      (T (COMPOSE3 L (CAR FIELD)
                                                   ('CAR DEF]
                                    (COND
                                      (KD (CAR KD))
                                      (T (COMPOSE3 L (CDR FIELD)
                                                   ('CDR DEF])

(COMPOSE3
  [LAMBDA (L FIELD DEF)

          (* Creates the defaalt value for field -- if there 
          was a FROM then it's just the from thing , otherwise 
          its a CONS of the individual fields)


    (COND
      (FROMVAR DEF)
      (T (COMPOSE4 FIELD])

(COMPOSE4
  [LAMBDA (FIELD)
    (COND
      ((NULL FIELD)
        NIL)
      [(ATOM FIELD)
        ([LAMBDA (X)
            (COND
              (X (KWOTE X]
          (GETP FIELD (QUOTE RECDEFAULT]
      (T ('CONS (COMPOSE4 (CAR FIELD))
                (COMPOSE4 (CDR FIELD])

(MAKECROPFN
  [LAMBDA (RCROPS)
    (OR [FGETD (PACK (CONS (QUOTE C)
                           (APPEND RCROPS (LIST (QUOTE R]
        (LIST (QUOTE LAMBDA)
              (QUOTE (RECORDFIELDVAR))
              (MAKECROPFN1 RCROPS])

(MAKECROPFN1
  [LAMBDA (RCROPS)
    (COND
      ((NULL RCROPS)
        (QUOTE RECORDFIELDVAR))
      ((NULL (CDDDDR RCROPS))
        (LIST [PACK (CONS (QUOTE C)
                          (APPEND RCROPS (QUOTE (R]
              (QUOTE RECORDFIELDVAR)))
      (T (LIST (PACK (LIST (QUOTE C)
                           (CAR RCROPS)
                           (CADR RCROPS)
                           (CADDR RCROPS)
                           (CADDDR RCROPS)
                           (QUOTE R)))
               (MAKECROPFN1 (CDDDDR RCROPS])

(CLISPLOOKUP
  [LAMBDA (FN VAR1 VAR2 LISPFN)

          (* In most cases, it is not necessary to do a full 
          lookup. This is q uick an dirty check inside of the 
          block to avoid calling CLISPLOOKUP0 It will work 
          whenever there are no declarations.
          Only difference between this and CLISPIFYLOOKUP is 
          that is that we already have performed 
          (GETP FN 'LISPFN))


    (PROG (CLASS TEM)
          (RETURN (COND
                    ([OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
                              (EQ (CAR (SETQ TEM (CADDR EXPR)))
                                  (QUOTE *))
                              (EQ (CADR TEM)
                                  (QUOTE DECLARATIONS:))
                              (SETQ TEM (CDDDR TEM)))
                         (AND (EQ (CAR TEM)
                                  (QUOTE CLISP:))
                              (SETQ TEM (CLISPDEC0 TEM FAULTFN]
                                                (* must do full lookup.)
                      (CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS))
                    (T (OR LISPFN FN])

(LOOK
  [LAMBDA (FN ARG1 ARG2)
    (LIST (CLISPLOOKUP FN ARG1 ARG2 (GETP FN (QUOTE LISPFN)))
          ARG1 ARG2])
)
(DEFLIST(QUOTE(
  (COMPOSE (T . compose))
  (compose (T . compose))
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
  [COMPOSE (X (COMPOSE0 (REMOVE (QUOTE =)
                                (CDR X))
                        (OR (GETP (CAR X)
                                  (QUOTE RECORD))
                            (GETP (CAR X)
                                  (QUOTE TYPERECORD))
                            (ERROR (CAR X)
                                   "not a record" T))
                        (AND (GETP (CAR X)
                                   (QUOTE TYPERECORD))
                             (CAR X]
  [compose (X (COMPOSE0 (CDR X)
                        (OR (GETP (CAR X)
                                  (QUOTE RECORD))
                            (GETP (CAR X)
                                  (QUOTE TYPERECORD))
                            (ERROR (CAR X)
                                   "not a record" T))
                        (AND (GETP (CAR X)
                                   (QUOTE TYPERECORD))
                             (CAR X]
))(QUOTE MACRO))

  (ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORD "records"))
  (ADDTOVAR CLISPRETTYWORDS compose COMPOSE)
  (ADDTOVAR CLISPWORDS COMPOSE)
  (RPAQ CHANGEDRECLST NIL)
STOP